home *** CD-ROM | disk | FTP | other *** search
/ Aminet 28 / Aminet 28 (1998)(GTI - Schatztruhe)[!][Dec 1998].iso / Aminet / dev / lang / fpc09905c.lha / fpc / inc / sstrings.inc < prev    next >
Text File  |  1998-09-21  |  15KB  |  787 lines
  1. {
  2.     $Id: sstrings.inc,v 1.11 1998/08/11 21:39:07 peter Exp $
  3.     This file is part of the Free Pascal run time library.
  4.     Copyright (c) 1993,97 by the Free Pascal development team
  5.  
  6.     See the file COPYING.FPC, included in this distribution,
  7.     for details about the copyright.
  8.  
  9.     This program is distributed in the hope that it will be useful,
  10.     but WITHOUT ANY WARRANTY; without even the implied warranty of
  11.     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  12.  
  13.  **********************************************************************}
  14.  
  15. {****************************************************************************
  16.                     subroutines for string handling
  17. ****************************************************************************}
  18.  
  19. {$I real2str.inc}
  20.  
  21. function copy(const s : string;index : StrLenInt;count : StrLenInt): string;
  22.  
  23. begin
  24.   if count<0 then
  25.    count:=0;
  26.   if index>1 then
  27.    dec(index)
  28.   else
  29.    index:=0;
  30.   if index>length(s) then
  31.    count:=0
  32.   else
  33.    if index+count>length(s) then
  34.     count:=length(s)-index;
  35.   Copy[0]:=chr(Count);
  36.   Move(s[Index+1],Copy[1],Count);
  37. end;
  38.  
  39. procedure delete(var s : string;index : StrLenInt;count : StrLenInt);
  40.  
  41. begin
  42.   if index<=0 then
  43.     begin
  44.     count:=count+index-1;
  45.     index:=1;
  46.     end;
  47.   if (Index<=Length(s)) and (Count>0) then
  48.     begin
  49.     if Count+Index>length(s) then
  50.       Count:=length(s)-Index+1;
  51.     s[0]:=Chr(length(s)-Count);
  52.     if Index<=Length(s) then
  53.       Move(s[Index+Count],s[Index],Length(s)-Index+1);
  54.    end;
  55. end;
  56.  
  57. procedure insert(const source : string;var s : string;index : StrLenInt);
  58.  
  59. begin
  60.   if index>1 then
  61.    dec(index)
  62.   else
  63.    index:=0;
  64.   s:=Copy(s,1,Index)+source+Copy(s,Index+1,length(s));
  65. end;
  66.  
  67. function pos(const substr : string;const s : string): byte;
  68.  
  69. var i,j : longint;
  70.     e : boolean;
  71.  
  72. begin
  73.    i := 0;
  74.    j := 0;
  75.    e:=(length(SubStr)>0);
  76.    while e and (i<=Length(s)-Length(SubStr)) do
  77.     begin
  78.       inc(i);
  79.       if (SubStr[1]=s[i]) and (Substr=Copy(s,i,Length(SubStr))) then
  80.        begin
  81.          j:=i;
  82.          e:=false;
  83.        end;
  84.     end;
  85.    Pos:=j;
  86. end;
  87.  
  88. {Faster when looking for a single char...}
  89.  
  90. function pos(c:char;const s:string):byte;
  91.  
  92. var i:longint;
  93.  
  94. begin
  95.     for i:=1 to length(s) do
  96.         if s[i]=c then
  97.             begin
  98.                 pos:=i;
  99.                 exit;
  100.             end;
  101.     pos:=0;
  102. end;
  103.  
  104. {$ifdef IBM_CHAR_SET}
  105. const
  106.   UpCaseTbl : string[7]=#154#142#153#144#128#143#165;
  107.   LoCaseTbl : string[7]=#129#132#148#130#135#134#164;
  108. {$endif}
  109.  
  110. function upcase(c : char) : char;
  111.  
  112. {$IFDEF IBM_CHAR_SET}
  113. var
  114.   i : longint;
  115. {$ENDIF}
  116. begin
  117.   if (c in ['a'..'z']) then
  118.     upcase:=char(byte(c)-32)
  119.   else
  120. {$IFDEF IBM_CHAR_SET}
  121.     begin
  122.       i:=Pos(c,LoCaseTbl);
  123.       if i>0 then
  124.        upcase:=UpCaseTbl[i]
  125.       else
  126.        upcase:=c;
  127.     end;
  128. {$ELSE}
  129.    upcase:=c;
  130. {$ENDIF}
  131.     end;
  132.  
  133. function upcase(const s : string) : string;
  134.  
  135. var i : longint;
  136.  
  137. begin
  138.   upcase[0]:=s[0];
  139.   for i := 1 to length (s) do
  140.     upcase[i] := upcase (s[i]);
  141. end;
  142.  
  143. {$ifndef RTLLITE}
  144.  
  145. function lowercase(c : char) : char;
  146. {$IFDEF IBM_CHAR_SET}
  147. var
  148.   i : longint;
  149. {$ENDIF}
  150. begin
  151.   if (c in ['A'..'Z']) then
  152.    lowercase:=char(byte(c)+32)
  153.   else
  154. {$IFDEF IBM_CHAR_SET}
  155.    begin
  156.      i:=Pos(c,UpCaseTbl);
  157.      if i>0 then
  158.       lowercase:=LoCaseTbl[i]
  159.      else
  160.       lowercase:=c;
  161.    end;
  162.  {$ELSE}
  163.    lowercase:=c;
  164.  {$ENDIF}
  165. end;
  166.  
  167. function lowercase(const s : string) : string;
  168.  
  169. var i : longint;
  170.  
  171. begin
  172.   lowercase [0] := s[0];
  173.   for i := 1 to length (s) do
  174.      lowercase[i] := lowercase (s[i]);
  175. end;
  176.  
  177. function hexstr(val : longint;cnt : byte) : string;
  178.  
  179. const
  180.   HexTbl : array[0..15] of char='0123456789ABCDEF';
  181. var
  182.   i : longint;
  183. begin
  184.   hexstr[0]:=char(cnt);
  185.   for i:=cnt downto 1 do
  186.    begin
  187.      hexstr[i]:=hextbl[val and $f];
  188.      val:=val shr 4;
  189.    end;
  190. end;
  191.  
  192.  
  193.  
  194.  function binstr(val : longint;cnt : byte) : string;
  195.  
  196. var
  197.   i : longint;
  198. begin
  199.   binstr[0]:=char(cnt);
  200.   for i:=cnt downto 1 do
  201.    begin
  202.      binstr[i]:=char(48+val and 1);
  203.      val:=val shr 1;
  204.    end;
  205. end;
  206.  
  207. {$endif RTLLITE}
  208.  
  209.  function space (b : byte): string;
  210.  
  211.  begin
  212.     space[0] := chr(b);
  213.     FillChar (Space[1],b,' ');
  214.  end;
  215.  
  216. {*****************************************************************************
  217.                               Str() Helpers
  218. *****************************************************************************}
  219.  
  220. procedure int_str_real(d : real;len,fr : longint;var s : string);[public, alias : 'STR_REAL'];
  221. begin
  222. {$ifdef i386}
  223.    str_real(len,fr,d,rt_s64real,s);
  224. {$else}
  225.    str_real(len,fr,d,rt_s32real,s);
  226. {$endif}
  227. end;
  228.  
  229. {$ifdef SUPPORT_SINGLE}
  230. procedure int_str_single(d : single;len,fr : longint;var s : string);[public, alias : 'STR_SINGLE'];
  231. begin
  232.    str_real(len,fr,d,rt_s32real,s);
  233. end;
  234. {$endif SUPPORT_SINGLE}
  235.  
  236.  
  237. {$ifdef SUPPORT_EXTENDED}
  238. procedure int_str_extended(d : extended;len,fr : longint;var s : string);[public, alias : 'STR_EXTENDED'];
  239. begin
  240.    str_real(len,fr,d,rt_s80real,s);
  241. end;
  242. {$endif SUPPORT_EXTENDED}
  243.  
  244.  
  245. {$ifdef SUPPORT_COMP}
  246. procedure int_str_comp(d : comp;len,fr : longint;var s : string);[public, alias : 'STR_COMP'];
  247. begin
  248.    str_real(len,fr,d,rt_s64bit,s);
  249. end;
  250. {$endif SUPPORT_COMP}
  251.  
  252.  
  253. {$ifdef SUPPORT_FIXED}
  254. procedure int_str_fixed(d : fixed;len,fr : longint;var s : string);[public, alias : 'STR_FIXED'];
  255. begin
  256.    str_real(len,fr,d,rt_f32bit,s);
  257. end;
  258. {$endif SUPPORT_FIXED}
  259.  
  260.  
  261. procedure int_str_longint(v : longint;len : longint;var s : string);[public, alias : 'STR_LONGINT'];
  262. begin
  263.    int_str(v,s);
  264.    if length(s)<len then
  265.      s:=space(len-length(s))+s;
  266. end;
  267.  
  268.  
  269. procedure int_str_cardinal(v : cardinal;len : longint;var s : string);[public, alias : 'STR_CARDINAL'];
  270. begin
  271.   int_str(v,s);
  272.   if length(s)<len then
  273.     s:=space(len-length(s))+s;
  274. end;
  275.  
  276.  
  277. {*****************************************************************************
  278.                            Val() Functions
  279. *****************************************************************************}
  280.  
  281. Function InitVal(const s:string;var negativ:boolean;var base:byte):Word;
  282. var
  283.   Code : Longint;
  284. begin
  285. {Skip Spaces and Tab}
  286.   code:=1;
  287.   while (code<=length(s)) and (s[code] in [' ',#9]) do
  288.    inc(code);
  289. {Sign}
  290.   negativ:=false;
  291.   case s[code] of
  292.    '-' : begin
  293.            negativ:=true;
  294.            inc(code);
  295.          end;
  296.    '+' : inc(code);
  297.   end;
  298. {Base}
  299.   base:=10;
  300.   if code<=length(s) then
  301.    begin
  302.      case s[code] of
  303.       '$' : begin
  304.               base:=16;
  305.               repeat
  306.                 inc(code);
  307.               until (code>=length(s)) or (s[code]<>'0');
  308.               if length(s)-code>7 then
  309.                code:=code+8;
  310.             end;
  311.       '%' : begin
  312.               base:=2;
  313.               inc(code);
  314.             end;
  315.      end;
  316.   end;
  317.   InitVal:=code;
  318. end;
  319.  
  320.  
  321. procedure val(const s : string;var l : longint;var code : word);
  322. var
  323.   base,u  : byte;
  324.   negativ : boolean;
  325. begin
  326.   l:=0;
  327.   Code:=InitVal(s,negativ,base);
  328.   if Code>length(s) then
  329.    exit;
  330.   if negativ and (s='-2147483648') then
  331.    begin
  332.      Code:=0;
  333.      l:=$80000000;
  334.      exit;
  335.    end;
  336.   while Code<=Length(s) do
  337.    begin
  338.      u:=ord(s[code]);
  339.      case u of
  340.        48..57 : u:=u-48;
  341.        65..70 : u:=u-55;
  342.       97..104 : u:=u-87;
  343.      else
  344.       u:=16;
  345.      end;
  346.      l:=l*longint(base);
  347.      if (u>=base) or ((base=10) and (2147483647-l<longint(u))) then
  348.       begin
  349.         l:=0;
  350.         exit;
  351.       end;
  352.      l:=l+u;
  353.      inc(code);
  354.    end;
  355.   code := 0;
  356.   if negativ then
  357.    l:=0-l;
  358. end;
  359.  
  360.  
  361. procedure val(const s : string;var l : longint;var code : integer);
  362. begin
  363.   val(s,l,word(code));
  364. end;
  365.  
  366.  
  367. procedure val(const s : string;var l : longint);
  368. var
  369.   code : word;
  370. begin
  371.    val (s,l,code);
  372. end;
  373.  
  374.  
  375. procedure val(const s : string;var b : byte);
  376. var
  377.   l : longint;
  378. begin
  379.   val(s,l);
  380.   b:=l;
  381. end;
  382.  
  383.  
  384. procedure val(const s : string;var b : byte;var code : word);
  385. var
  386.   l : longint;
  387. begin
  388.   val(s,l,code);
  389.   b:=l;
  390. end;
  391.  
  392.  
  393. procedure val(const s : string;var b : byte;var code : Integer);
  394. begin
  395.   val(s,b,word(code));
  396. end;
  397.  
  398.  
  399. procedure val(const s : string;var b : shortint);
  400. var
  401.   l : longint;
  402. begin
  403.   val(s,l);
  404.   b:=l;
  405. end;
  406.  
  407.  
  408. procedure val(const s : string;var b : shortint;var code : word);
  409. var
  410.   l : longint;
  411. begin
  412.   val(s,l,code);
  413.   b:=l;
  414. end;
  415.  
  416.  
  417. procedure val(const s : string;var b : shortint;var code : Int